home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / tj50dsk1.zip / FASTTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1989-01-31  |  11KB  |  412 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.00                              }
  5. {                                                                          }
  6. {                                                                          }
  7. {              Copyright 1986, 1989 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}                                       
  13.                      {       Unit:  FastTTT5          }
  14.                      {--------------------------------}
  15.  
  16.  
  17. {$S-,R-,V-,D-}       
  18.  
  19. unit FastTTT5;
  20.  
  21. interface
  22.  
  23. Uses DOS, CRT;
  24.  
  25. const
  26.     MaxScreenStr = 80;
  27.     FCol:byte = white;
  28.     BCol:byte = black;
  29. type
  30.   StrScreen = string[MaxScreenStr];
  31. var
  32.   BaseOfScreen : Word;       {Base address of video memory}
  33.   VSeg : word;               {Base address of active screen}
  34.   VOfs : word;                   {Base address of active screen}
  35.   SnowProne : Boolean;       {Check for snow on color cards?}
  36.   Speed : longint;           {delay factor for growbox routine}
  37.  
  38. Function  ColorScreen:boolean;
  39. Function  Attr(F,B:byte):byte;
  40. Procedure FastWrite(Col,Row,Attr:byte; St:StrScreen);
  41. Procedure PlainWrite(Col,Row:byte; St:StrScreen);
  42. Procedure ColWrite(Col,Row:byte; St:StrScreen);
  43. Procedure FWrite(St:StrScreen);
  44. Procedure FWriteLN(St:StrScreen);
  45. Procedure Attrib(X1,Y1,X2,Y2,F,B:byte);
  46. Procedure Clickwrite(Col,Row,F,B:byte; St:StrScreen);
  47. Function  Replicate(N:byte; Character:char):StrScreen;
  48. Procedure Box(X1,Y1,X2,Y2,F,B,boxtype:integer);
  49. Procedure FBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  50. Procedure GrowFBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  51. Procedure HorizLine(X1,X2,Y,F,B,lineType:byte);
  52. Procedure VertLine(X,Y1,Y2,F,B,lineType:byte);
  53. Procedure ClearText(x1,y1,x2,y2,F,B:integer);
  54. Procedure ClearLine(Y,F,B:integer);
  55. Procedure WriteAT(X,Y,F,B:integer; St:StrScreen);
  56. Procedure WriteBetween(X1,X2,Y,F,B:byte; St:StrScreen);
  57. Procedure WriteCenter(LineNO,F,B:integer; St:StrScreen);
  58. Procedure WriteVert(X,Y,F,B:integer; St:StrScreen);
  59. Function  EGAVGASystem: boolean;
  60. Procedure InitFastTTT;
  61.  
  62. implementation
  63.  
  64.   {$L FASTTTT5}
  65.  
  66.   {$F+}
  67.   Procedure FastWrite(Col,Row,Attr:byte; St:StrScreen); external;
  68.   Procedure PlainWrite(Col,Row:byte; St:StrScreen); external;
  69.   Procedure Attribute(Col,Row,Attr:byte; Number:Word); external;
  70.   {$F-}
  71.  
  72.   Function ColorScreen: boolean;
  73.   {}
  74.   begin
  75.       ColorScreen := (BaseOfScreen = $B800);
  76.   end; {of func ColorScreen}
  77.  
  78.   Function Attr(F,B:byte):byte;
  79.   {converts foreground(F) and background(B) colors to combined Attribute byte}
  80.   begin
  81.       Attr := (B Shl 4) or F;
  82.   end;  {Func Attr}
  83.  
  84.   Procedure ColWrite(Col,Row:byte; St:StrScreen);
  85.   begin
  86.       Fastwrite(Col,Row,attr(FCol,BCol),St);
  87.   end;
  88.  
  89.   Procedure FWrite(St:StrScreen);
  90.   var Col,Row : byte;
  91.   begin
  92.       Col := WhereX;
  93.       Row := WhereY;
  94.       Fastwrite(Col,Row,attr(FCol,BCol),St);
  95.       GotoXY(Col+length(St),Row);
  96.   end;
  97.  
  98.   Procedure FWriteLN(St:StrScreen);
  99.   var Col,Row : byte;
  100.   begin
  101.       Col := WhereX;
  102.       Row := WhereY;
  103.       Fastwrite(Col,Row,attr(FCol,BCol),St);
  104.       GotoXY(1,succ(Row));
  105.   end;
  106.  
  107.   
  108.  
  109.   Procedure Attrib(X1,Y1,X2,Y2,F,B:byte);
  110.   {changes color attrib at specified coords}
  111.   var
  112.     I,X,A : byte;
  113.   begin
  114.       A := Attr(F,B);
  115.       X := Succ(X2-X1);
  116.       For I := Y1 to Y2 do
  117.           Attribute(X1,I,A,X);
  118.   end; {Proc Attrib}
  119.  
  120.  
  121.   Procedure Clickwrite(Col,Row,F,B:byte; St:StrScreen);
  122.   {writes text to the screen with a click!}
  123.   var
  124.     I : Integer;
  125.     L,A : byte;
  126.   begin
  127.       A := attr(F,B);
  128.       L := length(St);
  129.       For I := L downto 1 do
  130.       begin
  131.           Fastwrite(Col,Row,A,copy(St,I,succ(L-I)));
  132.           sound(500);delay(20);nosound;delay(30);
  133.       end;
  134.   end;
  135.  
  136.   Function Replicate(N : byte; Character:char):StrScreen;
  137.   {returns a string with Character repeated N times}
  138.   var tempstr : StrScreen;
  139.   begin
  140.       If N = 0 then
  141.          TempStr := ''
  142.       else
  143.       begin
  144.          If (N > 80) then
  145.             N := 1;
  146.          fillchar(tempstr,N+1,Character);
  147.          Tempstr[0] := chr(N);
  148.       end;
  149.       Replicate := Tempstr;
  150.   end;
  151.  
  152.   Procedure ClearText(x1,y1,x2,y2,F,B:integer);
  153.   var
  154.     Y : integer;
  155.     attrib : byte;
  156.   begin
  157.       If x2 > 80 then x2 := 80;
  158.       Attrib := attr(F,B);
  159.       For Y := y1 to y2 do
  160.           Fastwrite(X1,Y,attrib,replicate(X2-X1+1,' '));
  161.   end;   {cleartext}
  162.  
  163.   Procedure ClearLine(Y,F,B:integer);
  164.   begin
  165.       Fastwrite(1,Y,attr(F,B),replicate(80,' '));
  166.   end;
  167.  
  168.   Procedure Box(X1,Y1,X2,Y2,F,B,boxtype:integer);
  169.   {Draws a box on the screen}
  170.   var
  171.     I:integer;
  172.     corner1,corner2,corner3,corner4,
  173.     horizline,
  174.     vertline : char;
  175.     attrib : byte;
  176.   begin
  177.       case boxtype of
  178.       0:begin
  179.             corner1:=' ';
  180.             corner2:=' ';
  181.             corner3:=' ';
  182.             corner4:=' ';
  183.             horizline:=' ';
  184.             vertline:=' ';
  185.         end;
  186.       1:begin
  187.             corner1:='┌';
  188.             corner2:='┐';
  189.             corner3:='└';
  190.             corner4:='┘';
  191.             horizline:='─';
  192.             vertline:='│';
  193.         end;
  194.       2:begin
  195.             corner1:='╔';
  196.             corner2:='╗';
  197.             corner3:='╚';
  198.             corner4:='╝';
  199.             horizline:='═';
  200.             vertline:='║';
  201.         end;
  202.       3:begin
  203.             corner1:='╓';
  204.             corner2:='╖';
  205.             corner3:='╙';
  206.             corner4:='╜';
  207.             horizline:='─';
  208.             vertline:='║';
  209.         end;
  210.       4:begin
  211.             corner1:='╒';
  212.             corner2:='╕';
  213.             corner3:='╘';
  214.             corner4:='╛';
  215.             horizline:='═';
  216.             vertline:='│';
  217.         end;
  218.     else
  219.        corner1:=chr(ord(Boxtype));
  220.        corner2:=chr(ord(Boxtype));
  221.        corner3:=chr(ord(Boxtype));
  222.        corner4:=chr(ord(Boxtype));
  223.        horizline:=chr(ord(Boxtype));
  224.        vertline:=chr(ord(Boxtype));
  225.     end;{case}
  226.     attrib := attr(F,B);
  227.     FastWrite(X1,Y1,attrib,corner1);
  228.     FastWrite(X1+1,Y1,attrib,replicate(X2-X1-1,horizline));
  229.     FastWrite(X2,Y1,attrib,corner2);
  230.     For I := Y1+1 to Y2-1 do
  231.     begin
  232.         FastWrite(X1,I,attrib,vertline);
  233.         FastWrite(X2,I,attrib,vertline);
  234.     end;
  235.     FastWrite(X1,Y2,attrib,corner3);
  236.     FastWrite(X1+1,Y2,attrib,replicate(X2-X1-1,horizline));
  237.     FastWrite(X2,Y2,attrib,corner4);
  238.   end; {Proc Box}
  239.  
  240.   Procedure FBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  241.   {Draws a box and clears text within Box frame}
  242.   begin
  243.       Box(X1,Y1,X2,Y2,F,B,boxtype);
  244.       ClearText(succ(X1),succ(Y1),pred(X2),pred(Y2),F,B);
  245.   end;
  246.  
  247.   Procedure GrowFBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  248.   {Draws exploding filled box!}
  249.   var I,TX1,TY1,TX2,TY2,Ratio : integer;
  250.   begin
  251.       If 2*(Y2 -Y1 +1) > X2 - X1 + 1 then
  252.          Ratio :=   2
  253.       else
  254.          Ratio :=  1;
  255.       TX2 := (X2 - X1) div 2 + X1 + 2;
  256.       TX1 := TX2 - 3;                 {needs a box 3 by 3 minimum}
  257.       TY2 := (Y2 - Y1) div 2 + Y1 + 2;
  258.       TY1 := TY2 - 3;
  259.       If (X2-X1) < 3 then
  260.       begin
  261.          TX2 := X2;
  262.          TX1 := X1;
  263.       end;
  264.       If (Y2-Y1) < 3 then
  265.       begin
  266.          TY2 := Y2;
  267.          TY1 := Y1;
  268.       end;
  269.       repeat
  270.            FBox(TX1,TY1,TX2,TY2,F,B,BoxType);
  271.            If TX1 >= X1 + (1*Ratio) then TX1 := TX1 - (1*Ratio) else TX1 := X1;
  272.            If TY1 > Y1  then TY1 := TY1 - 1;
  273.            If TX2 + (1*Ratio) <= X2 then TX2 := TX2 + (1*Ratio) else TX2 := X2;
  274.            If TY2 + 1 <= Y2 then TY2 := TY2 + 1;
  275.            For I := 1 to Speed*1000 do {nothing};
  276.       Until (TX1 = X1) and (TY1 = Y1) and (TX2 = X2) and (TY2 = Y2);
  277.       FBox(TX1,TY1,TX2,TY2,F,B,BoxType);
  278.   end;
  279.  
  280.   procedure HorizLine(X1,X2,Y,F,B,lineType : byte);
  281.   var
  282.     I : integer;
  283.     Horizline : char;
  284.     attrib : byte;
  285.   begin
  286.       If (lineType in [2,4,7,9]) then
  287.          horizline := '═'
  288.       else
  289.          horizline := '─';
  290.       Attrib := attr(F,B);
  291.       If X2 > X1 then
  292.          FastWrite(X1,Y,attrib,replicate(X2-X1+1,Horizline))
  293.       else
  294.          FastWrite(X1,Y,attrib,replicate(X1-X2+1,Horizline));
  295.   end;   {horizline}
  296.  
  297.   Procedure VertLine(X,Y1,Y2,F,B,lineType : byte);
  298.   var
  299.     I : integer;
  300.     vertline : char;
  301.     attrib : byte;
  302.   begin
  303.       If (linetype in [2,4])then
  304.          vertline := '║'
  305.       else
  306.          vertline := '│';
  307.       Attrib := attr(F,B);
  308.       If Y2 > Y1 then
  309.          For I := Y1 to Y2 do Fastwrite(X,I,Attrib,Vertline)
  310.       else
  311.          For I := Y2 to Y1 do Fastwrite(X,I,Attrib,Vertline);
  312.   end;   {vertline}
  313.  
  314.   Procedure WriteAT(X,Y,F,B:integer;St:StrScreen);
  315.   begin
  316.       Fastwrite(X,Y,attr(F,B),St);
  317.   end;
  318.  
  319.   Procedure WriteCenter(LineNO,F,B:integer;St:StrScreen);
  320.   begin
  321.       Fastwrite(40 - length(St) div 2,Lineno,attr(F,B),St);
  322.   end;
  323.  
  324.   Procedure WriteBetween(X1,X2,Y,F,B:byte;St:StrScreen);
  325.   var X : integer;
  326.   begin
  327.       If length(St) >= X2 - X1 + 1 then
  328.          WriteAT(X1,Y,F,B,St)
  329.       else
  330.       begin
  331.           x := X1 + (X2 - X1 + 1 - length(St)) div 2 ;
  332.           WriteAT(X,Y,F,B,St);
  333.       end;
  334.   end;
  335.  
  336.   Procedure WriteVert(X,Y,F,B:integer;ST : StrScreen);
  337.   var
  338.     I:integer;
  339.     Tempstr:StrScreen;
  340.   begin
  341.       If length(St) > 26 - Y then delete(St,27 - Y,80);
  342.       For I := 1 to length(St) do
  343.       begin
  344.           Tempstr := st[I];
  345.           Fastwrite(X,Y-1+I,attr(F,B),St[I]);
  346.       end;
  347.   end;
  348.  
  349.   Function EGAVGASystem: boolean;
  350.   {}
  351.   var  Regs : registers;
  352.   begin
  353.       with Regs do
  354.       begin
  355.           Ax := $1C00;
  356.           Cx := 7;
  357.           Intr($10,Regs);
  358.           If Al = $1C then  {VGA}
  359.           begin
  360.               EGAVGASystem := true;
  361.               exit;
  362.           end;
  363.           Ax := $1200;
  364.           Bl := $32;
  365.           Intr($10,Regs);
  366.           If Al = $12 then {MCGA}
  367.           begin
  368.               EGAVGASystem := true;
  369.               exit;
  370.           end;
  371.           Ah := $12;
  372.           Bl := $10;
  373.           Cx := $FFFF;
  374.           Intr($10,Regs);
  375.           EGAVGASystem := (Cx <> $FFFF);  {EGA}
  376.      end; {with}
  377.   end; {of func NoSnowSystem}
  378.  
  379.   Function Get_Video_Mode:byte;
  380.   {}
  381.   var
  382.      Regs : registers;
  383.   begin
  384.       with Regs do
  385.       begin
  386.           Ax := $0F00;
  387.           Intr($10,Regs);
  388.           Get_Video_Mode := Al;
  389.       end; {with}
  390.   end; {of proc Video_Mode}
  391.  
  392.   Procedure InitFastTTT;
  393.   begin
  394.       if Get_Video_Mode = 7 then
  395.       begin
  396.          BaseOfScreen := $B000;  {Mono}
  397.          SnowProne := False;
  398.       end
  399.       else
  400.       begin
  401.          BaseOfScreen := $B800; {Color}
  402.          SnowProne := not EGAVGASystem;
  403.       end;
  404.       VSeg := BaseOfScreen;
  405.       Vofs := 0;
  406.   end;
  407.  
  408. begin   {the following is always called when the unit is loaded}
  409.     InitFastTTT;
  410.     Speed := 200;
  411. end.
  412.